home *** CD-ROM | disk | FTP | other *** search
/ TeX 1995 July / TeX CD-ROM July 1995 (Disc 1)(Walnut Creek)(1995).ISO / macros / latex209 / contrib / textyl / psrc / textyl.pas.af < prev    next >
Text File  |  1993-11-07  |  26KB  |  1,001 lines
  1.         procedure gettransforms (var sc1, sc2, r : real;
  2.                                 var tr1, tr2 : integer);
  3.         label 22;
  4.         var i : integer;                                
  5.             dun : boolean;
  6.         begin
  7.           sc1 := 1.0; sc2 := 1.0;
  8.           tr1 := 0; tr2 := 0;
  9.           r := 0.0;
  10.           i := parsposit - 1;
  11.           if (i < 1) then
  12.             begin
  13.             goto 22; (* exit with defaults *)
  14.             end;
  15.           dun := false;
  16.           while ((i < parsmax) and not dun) do
  17.             begin
  18.             if (isaletter(parsearray[i])) then
  19.               begin
  20.               if ((parsearray[i] = xord['t']) or
  21.                   (parsearray[i] = xord['T'])) then
  22.                  begin
  23.                  if (isdelimiter(parsearray[i+1]) and
  24.              isdelimiter(parsearray[i-1])) then
  25.                     begin        (* get transform parameters *)
  26.                     sc1 := getnumber / 100.0;
  27.                     sc2 := getnumber / 100.0;
  28.                     tr1 := getnumber;
  29.                     tr2 := getnumber;
  30.                     r := float(getnumber); (* degrees about primitive center *)
  31.             if (r < 0.0) then
  32.               r := r + 360.0;
  33.                     dun := true;
  34.                     end;
  35.                  end;
  36.               end;
  37.             i := i + 1;
  38.             end; (* while *)
  39. 22:
  40.         end; (* gettransforms *)
  41.  
  42. {__________________________________________________________________}
  43.         function findmarker (markset : charset) : integer;
  44.         label 1111;
  45.         var i, sym : integer;
  46.            dun : boolean;
  47.         begin
  48.         i := parsposit - 1;
  49.         sym := EMPTY;
  50.         if (i < 1) then
  51.           goto 1111;
  52.         dun := false;
  53.         while ((i < parsmax) and not dun) do
  54.           begin
  55.           if (isaletter(parsearray[i])) then
  56.             begin
  57.             if (xchr[ parsearray[i] ] in markset) then
  58.                 begin
  59.                 if (isdelimiter (parsearray[i+1]) and
  60.             isdelimiter (parsearray[i-1])) then
  61.                   begin
  62.                   sym := xord[tolowercase(xchr[parsearray[i]])];
  63.                   dun := true;
  64.                   end;
  65.                 end;
  66.             end;  (* if a letter *)
  67.           i := i + 1;
  68.           end;  (* while *)
  69. 1111:     findmarker := sym;
  70.         end;
  71.  
  72.  
  73.  
  74.         function findscale : integer;
  75.         begin
  76.           findscale := findmarker(['s','S','p','P','m','M']);
  77.         end;
  78.  
  79.         function findvectkind : integer;
  80.         begin
  81.           findvectkind := findmarker(['c','C','h','H','v','V']);
  82.         end;  
  83.     
  84.     function findlinestyle : integer;
  85.     begin
  86.       findlinestyle := findmarker(['l','L']);
  87.     end;
  88.  
  89.         function findbeamkind : integer;
  90.         begin
  91.           findbeamkind := findmarker(['r','R','g','G']);
  92.         end;
  93.  
  94.         function findsplinekind : integer;
  95.         begin
  96.           findsplinekind := findmarker(['b','B','i','I','k','K','d','D']);
  97.         end;
  98.  
  99.         function findsplclosure : integer;
  100.         begin
  101.           findsplclosure := findmarker(['o','O','u','U']);
  102.         end;
  103.  
  104.         function findatsign : integer;
  105.         begin
  106.           findatsign := findmarker(['@']);
  107.         end;
  108.     
  109.     function finddotmark : integer;
  110.     begin
  111.       finddotmark := findmarker(['x','X']);
  112.     end;
  113.     
  114.     function findfigdimens : integer;
  115.     begin
  116.       findfigdimens := findmarker(['w','W']);
  117.     end;  
  118.     
  119.     function findfitsizes : integer;
  120.     begin
  121.       findfitsizes := findmarker(['f','F']);
  122.     end;
  123.  
  124.  
  125.    {_________________________________________________}
  126.    function thescaleof (scal : integer) : real;
  127.    begin
  128.     if (scal = xord['s']) then
  129.      thescaleof := 1 * magfactor
  130.     else if (scal = xord['p']) then
  131.      thescaleof := SPPERPT * magfactor
  132.     else if (scal = xord['m']) then
  133.      thescaleof := SPPERMM * magfactor
  134.     else if (scal = EMPTY) then
  135.      thescaleof := SPPERPT * magfactor;
  136.    end;
  137.     
  138.  
  139.    function thevectorof (vkin : integer) : VectKind;
  140.    begin
  141.      if (vkin = xord['c']) then
  142.        thevectorof := VKCirc
  143.      else if (vkin = xord['v']) then
  144.        thevectorof := VKVert
  145.      else if (vkin = xord['h']) then
  146.        thevectorof := VKHort
  147.      else if (vkin = EMPTY) then
  148.        thevectorof := VKCirc;
  149.    end;
  150.    
  151.    function thestyleof (linest : integer) : LineStyle;
  152.    begin
  153.      if ((linest > 3) or 
  154.          (linest < 0)) then linest := 0;
  155.      case linest of
  156.         0 : thestyleof := solid;
  157.     1 : thestyleof := dotted;
  158.     2 : thestyleof := dashed;
  159.     3 : thestyleof := dotdash;
  160.      end;
  161.    end;
  162.  
  163.       
  164.  
  165.  
  166. (* -----!!!!!!!!!!!!  HandleSpecials !!!!!!!!!!!!!------ *)
  167. begin 
  168.   tylnam     := 'tyl';
  169.   beginfigurenam := 'beginfigure';
  170.   endfigurenam     := 'endfigure';
  171.   linenam     := 'line';
  172.   splinenam     := 'spline';
  173.   ttsplnam     := 'ttspline';
  174.   beamnam     := 'beam';
  175.   tieslurnam     := 'tieslur';
  176.   arcnam     := 'arc';
  177.   labelnam     := 'label';
  178.   paramnam     := 'param';
  179.   usingstream     := true; (* getting bytes from dvifile *)
  180.  
  181.   specstart := DVIMark - (specnum - 239 + 1) - 1;
  182.  
  183.   ourxpos := h; ourypos := v;  (* note the global DVI (h,v) coords *)
  184.   i := 1;
  185.  
  186.   b := Dget1byte; (* prime the reading scheme *)
  187.   gotten := (specnum - 239 + 1);
  188.  
  189.   while (isaspace(b)) do
  190.     b := nextpbyte;
  191.  
  192.   let := getletter;
  193.   while (let <> ' ') do (* get the name of the system --- Hopefully 'tyl' *)
  194.     begin
  195.     sysnam.str[i] := tolowercase(let);
  196.     sysnam.len := i;
  197.     i := i + 1;
  198.     let := getletter;
  199.     end;
  200.  
  201.    sysnam.str[i] := chr(32); (* end of string *)  
  202.  
  203.   if (not streq (sysnam.str, tylnam, 3)) then   (* TeXtyl doesnt know about this special *)
  204.     begin
  205.     write (logfile,'The special: ');
  206.     writestrng(sysnam,true);
  207.     writeln(logfile,'    is not tyl-able. Skipping...');
  208.     while (gotten < numpbytes) do
  209.       b := nextpbyte;
  210.     goto 888;
  211.     end;
  212.  
  213. (* OTHERWISE: all is okay. Lets look for a primitive to tyl *)
  214.  
  215.   while (isdelimiter(b)) do
  216.     begin
  217.       b := nextpbyte;
  218.     end;
  219.   i := 1;
  220.   let := getletter; {xchr[b];}
  221.   while (not (isdelimiter(xord[let]))) do (* get the name of the primitive *)
  222.     begin
  223.     nam.str[i] := tolowercase(let);
  224.     nam.len := i;
  225.     i := i + 1;
  226.     let := getletter;
  227.     end;
  228.  
  229.    nam.str[i] := chr(32); (* end of string *)  
  230.  
  231.  
  232.   let := xchr[b];
  233.  
  234. (* Now, fill the parse array with bytes so that we can get
  235.    the given parameters, and infer the defaulted params *)
  236.  
  237.   parsmax := min (PARSLEN, ((numpbytes - gotten) + 1));
  238.  
  239.   if (parsmax > 1) then
  240.     begin
  241.     parsearray[1] := xord[' ']; (* we need this *)
  242.     parsearray[2] := b;     (* start filling *)
  243.     for i := 3 to parsmax do
  244.        begin        (* fill rest *)
  245.        parsearray[i] := nextpbyte;
  246.        end;
  247.     parsposit := 1;
  248.     usingstream := false; (* now we look at bytes in parse array *)  
  249.     b := nextpbyte;       (* start it *)
  250.     end
  251.   else
  252.     begin
  253.     usingstream := true;
  254.     parsposit := -1; (* undefined *)
  255.     end;
  256.  
  257.                 (* --- BEGINFIGURE ---- *)
  258.   if streq(nam.str, beginfigurenam, 3) then 
  259.     begin
  260.     multifigure := multifigure + 1;
  261.     i := findscale;
  262.     SPscale := thescaleof (i);
  263.  
  264.     gettransforms (sx100, sy100, rot, transx, transy);
  265.     (* store all the primitives on pageitems, and dont output
  266.         them until we get a endfigure. this way, we can take
  267.         care of dealing with all the primitives according to
  268.         some global tranformation for the whole figure *)
  269.       pi := NewItem (Afigure);
  270.       with pi^ do
  271.         begin
  272.         figtheta := rot;
  273.         fsx := sx100;   fsy := sy100;
  274.         fdx := round (transx * SPscale);  
  275.         fdy := round (transy * SPscale);
  276.         depthnumber := multifigure; (* we're at a new level *)
  277.     i := findfigdimens;
  278.     if (i <> EMPTY) then
  279.       begin
  280.       preWid := round (getnumber * SPscale);
  281.       preHt := round (getnumber * SPscale);
  282.       end;
  283.     i := findfitsizes;
  284.     if (i <> EMPTY) then
  285.       begin
  286.       postWid := round (getnumber * SPscale);
  287.       postHt := round (getnumber * SPscale);
  288.       end;
  289.         end;  (* with *)
  290.       BackupInBuf (DVIMark - specstart);
  291.       pushItem (multifigure - 1, pi);
  292.       goto 888;
  293.     end;
  294.                 (* ---- ENDFIGURE ---- *)
  295.   if streq(nam.str, endfigurenam, 3) then
  296.     begin
  297.     multifigure := multifigure - 1;
  298.     if (multifigure < 0) then
  299.       begin
  300.       complain (ERRBAD);
  301.       write(logfile,'Warning: Too many "endfigure"s !');
  302.       multifigure := 0;
  303.       end;
  304.     BackupInBuf (DVIMark - specstart);
  305.  
  306.     if (multifigure = 0) then
  307.       begin
  308.          (* go do our set of figures (within figures...) *)
  309.       figurehandle (pageitems, pageitems, 1);
  310.       dispose (pageitems);      (* ### should maybe garbage collect here *)
  311.       pageitems := nil; 
  312.       end;  (* if *)
  313.     goto 888;
  314.     end;
  315.  
  316.                 (* --- LINE  --- *)
  317.    if streq(nam.str, linenam, 3) then
  318.      begin              
  319.      i := findscale;
  320.      SPscale := thescaleof(i);
  321.  
  322.      gettransforms (sx100, sy100, rot, transx, transy);
  323.      thk := getnumber; (* get the vector thickness *)
  324.      if (thk < 1) then
  325.        begin
  326.        complain (ERRBAD);
  327.        writeln(logfile,'?? Thickness not found. Setting to 1');
  328.        thk := 1;
  329.        end;
  330.      i := findvectkind;
  331.      vk := thevectorof (i);
  332.  
  333.      i := findlinestyle;
  334.      if (i <> EMPTY) then
  335.        patt := thestyleof (getnumber)
  336.      else
  337.        patt := solid;
  338.           
  339.      x1 := round (getnumber * SPscale);
  340.      y1 := round (getnumber * SPscale);
  341.      x2 := round (getnumber * SPscale);
  342.      y2 := round (getnumber * SPscale);
  343.  
  344.      minx := min (x1, x2);
  345.      maxx := max (x1, x2);
  346.      miny := min (y1, y2);
  347.      maxy := max (y1, y2);
  348.   
  349.      BackupInBuf (DVIMark - (specstart)); 
  350.      cmd1byte (OURFONTFLAG);
  351.      linehandle (multifigure, SPscale, x1, y1, x2, y2, 0, 0, thk, vk, patt,
  352.                  minx, maxx, miny, maxy,
  353.                         transx, transy, sx100, sy100, rot);
  354.    end (* line *)
  355.                 (* ---- THE SPLINES ---- *)
  356. else if (streq(nam.str, splinenam, 3) or
  357.          streq(nam.str, ttsplnam,3)) then
  358.    begin
  359.     i := findscale;
  360.     SPscale := thescaleof (i);
  361.  
  362.    gettransforms (sx100, sy100, rot, transx, transy);
  363.    
  364.    if streq(nam.str, splinenam, 3) then
  365.      begin
  366.      thk := getnumber;
  367.      if (thk < 1) then
  368.        begin
  369.        complain (ERRBAD);
  370.        writeln(logfile,'Spline Thickness not found. Setting to 1');
  371.        thk := 1;
  372.        end;     
  373.      end;
  374.      i := findvectkind;
  375.      vk := thevectorof (i);
  376.  
  377.      i := findlinestyle;
  378.      if (i <> EMPTY) then
  379.        patt := thestyleof (getnumber)
  380.      else
  381.        patt := solid;
  382.  
  383.      i := findsplinekind;
  384.      if (i = xord['b']) then
  385.        splinetype := BSPL
  386.      else if (i = xord['i']) then
  387.        splinetype := INTBSPL
  388.      else if (i = xord['k']) then
  389.        splinetype := CATROM
  390.      else if (i = xord['d']) then
  391.        splinetype := CARD
  392.      else if (i = EMPTY) then
  393.        splinetype := CATROM;
  394.        
  395.      i := findsplclosure;
  396.      if (i = xord['o']) then
  397.        isclosedspline := true
  398.      else if (i = xord['u']) then
  399.        isclosedspline := false
  400.      else if (i = EMPTY) then
  401.        isclosedspline := false;
  402.  
  403.      i := finddotmark;
  404.      if (i = xord['x']) then
  405.        markdiam := getnumber
  406.      else if (i = EMPTY) then
  407.        markdiam := 0;
  408.             
  409.    numknots := min (getnumber, MAXCTLPTS);
  410.    if (numknots < 1) then
  411.      begin
  412.      complain (ERRBAD);
  413.      writeln(logfile,'Number of spline/ttspline knot points not found. Setting to 1');
  414.      numknots := 1;
  415.      end;
  416.  
  417.    minx := TWO24; miny := TWO24;
  418.    maxx := -TWO24; maxy := -TWO24;
  419.    
  420.    for i := 0 to (numknots + 3) do
  421.      begin
  422.      cpts[i,1] := 0;
  423.      cpts[i,2] := 0;
  424.      end;  (* for *)
  425.  
  426.    for i := 1 to numknots do
  427.      begin
  428.      x1 := round (getnumber * SPscale);
  429.      cpts[i,1] := x1;
  430.      if (x1 < minx) then
  431.        minx := x1;
  432.      if (x1 > maxx) then
  433.        maxx := x1;
  434.      y1 := round (getnumber * SPscale);
  435.      cpts[i,2] := y1;
  436.      if (y1 < miny) then
  437.        miny := y1;
  438.      if (y1 > maxy) then
  439.        maxy := y1;
  440.      end; (* for *)
  441.  
  442.    if streq(nam.str, ttsplnam, 3) then
  443.      begin
  444.      for i := 1 to numknots do
  445.        begin
  446.        TTary[i] := getnumber;
  447.        end;
  448.      end;
  449.  
  450.    BackupInBuf (DVIMark - (specstart));
  451.    cmd1byte (OURFONTFLAG);
  452.  
  453.    if streq(nam.str, splinenam, 3) then
  454.      splinehandle (multifigure, SPscale, splinetype, isclosedspline,
  455.            markdiam, cpts, numknots, 
  456.                    0, 0, thk, vk, patt, minx, maxx, miny, maxy, 
  457.                    transx, transy, sx100, sy100, rot)
  458.    else
  459.      ttsplhandle (multifigure, SPscale, splinetype, isclosedspline,
  460.            markdiam, cpts, TTary, numknots, 
  461.                    0, 0, vk, patt, minx, maxx, miny, maxy, 
  462.                    transx, transy, sx100, sy100, rot);
  463.    end (* splines *)
  464.                 (* --- BEAMS ---- *)
  465.  else if streq(nam.str, beamnam, 4) then
  466.     begin
  467.     i := findscale;
  468.     SPscale := thescaleof (i);
  469.     
  470.     (* no transforms *)
  471.  
  472.     siz := getnumber; (* the staffsize *)
  473.     i := findbeamkind;
  474.     if (i = xord['g']) then
  475.       bk := grace
  476.     else if (i = xord['r']) then
  477.       bk := regular
  478.     else if (i = EMPTY) then
  479.       bk := regular;
  480.  
  481.     x1 := round (getnumber * SPscale);  
  482.     y1 := round (getnumber * SPscale);
  483.     x2 := round (getnumber * SPscale);
  484.     y2 := round (getnumber * SPscale);
  485.  
  486.     BackupInBuf (DVIMark - (specstart));
  487.     cmd1byte (OURFONTFLAG);
  488.  
  489.     beamhandle (multifigure, siz, bk, x1, y1, x2, y2);
  490.     end (* beam *)
  491.                 (* ---- TIES AND SLURS ---- *)
  492.   else if streq(nam.str, tieslurnam, 3) then
  493.     begin
  494.     i := findscale;
  495.     SPscale := thescaleof (i);
  496.  
  497.      minthk := getnumber;
  498.      if (minthk < 1) then
  499.        begin
  500.        complain (ERRBAD);
  501.        writeln(logfile,'Tie/Slur Min Thickness not found. Setting to 1');
  502.        minthk := 1;
  503.        end;
  504.    
  505.      maxthk := getnumber;
  506.      if (maxthk < 1) then
  507.        begin
  508.        complain (ERRBAD);
  509.        writeln(logfile,'Tie/Slur MaxThickness not found. Setting to 1');
  510.        maxthk := 1;
  511.        end;
  512.  
  513.      numknots := min (getnumber, MAXCTLPTS);
  514.      if (numknots < 1) then
  515.        begin
  516.        complain (ERRBAD);
  517.        writeln(logfile,'Tie/Slur Number of knot points not found. Setting to 1. Should be 5');
  518.        numknots := 1;
  519.        end;
  520.      for i := 1 to numknots do
  521.        begin
  522.        cpts[i,1] := round (getnumber * SPscale);
  523.        cpts[i,2] := round (getnumber * SPscale);
  524.        end;  (* for *)
  525.     BackupInBuf (DVIMark - (specstart));
  526.     cmd1byte (OURFONTFLAG);
  527.  
  528.     tieslurhandle (multifigure, cpts, numknots, minthk, maxthk);     
  529.     end (* ties and slurs *)
  530.     (* --------- ARCS and CIRCLES --------- *)
  531.   else if streq (nam.str, arcnam, 3) then
  532.     begin
  533.     i := findscale;
  534.     SPscale := thescaleof (i);
  535.  
  536.    gettransforms (sx100, sy100, rot, transx, transy);
  537.    
  538.    thk := getnumber;
  539.    if (thk < 1) then
  540.      begin
  541.      complain (ERRBAD);
  542.      writeln(logfile,'Arc Thickness not found. Setting to 1');
  543.      thk := 1;
  544.      end;     
  545.    i := findvectkind;
  546.    vk := thevectorof (i);
  547.  
  548.    i := findlinestyle;
  549.    if (i <> EMPTY) then
  550.      patt := thestyleof (getnumber)
  551.    else
  552.      patt := solid;
  553.   
  554.    radius := round (getnumber * SPscale);
  555.    if (radius = 0) then
  556.      radius := round(1 * SPscale);
  557.    i := findatsign;
  558.    if (i <> EMPTY) then
  559.      begin
  560.      x2 := round (getnumber * SPscale);
  561.      y2 := round (getnumber * SPscale);
  562.      end
  563.    else
  564.      begin
  565.      x2 := 0; y2 := 0;  (* assume center at origin *)
  566.      end; 
  567.   
  568.    ang1 := getnumber;
  569.    if (abs(ang1) > 360) then
  570.      ang1 := ang1 mod 360;
  571.    ang2 := getnumber;
  572.    if (abs(ang2) > 360) then
  573.      ang2 := ang2 mod 360;
  574.   
  575.    minx := TWO24; miny := TWO24;
  576.    maxx := -TWO24; maxy := -TWO24;
  577.    
  578.    if (ang1 = ang2) then
  579.      begin     (* a circle *)
  580.        defineCircleCpts (radius,x2,y2, cpts, numknots);
  581.      end
  582.    else
  583.      begin      (* a real arc *)
  584.      definearcpts (radius, x2,y2, ang1, ang2, cpts, numknots);
  585.      end;
  586.   
  587.    for i := 1 to numknots do
  588.      begin
  589.      x1 := cpts[i,1];
  590.      if (x1 < minx) then
  591.        minx := x1;
  592.      if (x1 > maxx) then
  593.        maxx := x1;
  594.   
  595.      y1 := cpts[i,2];
  596.      if (y1 < miny) then
  597.        miny := y1;
  598.      if (y1 > maxy) then
  599.        maxy := y1;
  600.      end; (* for *)
  601.   
  602.    BackupInBuf (DVIMark - (specstart));
  603.    cmd1byte (OURFONTFLAG);
  604.   
  605.    arccirclehandle (multifigure, SPscale, x2, y2, 
  606.            radius, ang1, ang2,
  607.            cpts, numknots, 
  608.            0, 0, thk, vk, patt, minx, maxx, miny, maxy, 
  609.            transx, transy, sx100, sy100, rot)
  610.   
  611.     end (* arc and circle *)
  612.     (* ---------- LABELS --------------*)
  613.   else if streq (nam.str, labelnam, 3) then
  614.     begin
  615.     i := findscale;
  616.     SPscale := thescaleof (i);
  617.   
  618.     style := getnumber; (* font style number *)
  619.     if ((style < 1) or (style > MAXLABELFONTS)) then
  620.       begin
  621.       complain (ERRBAD);
  622.       writeln(logfile,'Label style bad? Setting to Style 1');
  623.       style := 1;
  624.       end;
  625.   
  626.     x1 := round (getnumber * SPscale);
  627.     y1 := round (getnumber * SPscale);
  628.     
  629.     let := getletter;
  630.     while (let <> '"') do
  631.       begin
  632.       let := getletter;
  633.       end;
  634.     i := 0;
  635.     let := getanything; (* get next letter or whatever *)  
  636.     while (let <> '"') do
  637.       begin        (* get the label phrase *)
  638.       i := i + 1;
  639.       phrase.str[i] := let;
  640.       let := getanything; (* getletter;*)
  641.       end;
  642.  
  643.     phrase.str[i+1] := chr(32);
  644.  
  645.     phrase.len := i;
  646.   
  647.     BackupInBuf (DVIMark - specstart);
  648.     cmd1byte (OURFONTFLAG);
  649.     labelhandle (multifigure, SPscale, x1, y1, 0, 0, style, phrase, 0, 0);
  650.     end (* label *)
  651.  
  652.     (* --------- INTERNAL PARAM -------*)
  653.   else if streq (nam.str, paramnam, 3) then
  654.     begin
  655.     i := getnumber; (* addressable param number *)
  656.  
  657.       begin
  658.       writeln (logfile,' I do not know what internal parameter #',i:0,' is');
  659.       end;  (* else *)
  660.     BackupInBuf (DVIMark - (specstart));
  661.     end (* Internal param *)
  662.   
  663.       (* ==============  NONE OF THE ABOVE ============== *)
  664.   else
  665.     begin       
  666.     complain (ERRNOTBAD);
  667.     write (logfile,'Sorry, I don''t know how to tyl ');
  668.     writestrng (nam,true);
  669.       
  670.     while (gotten < numpbytes) do
  671.       begin
  672.       b := nextpbyte;
  673.       end;
  674.     end;
  675.   888:
  676.       (* make sure that we used up all the bytes in this special *)
  677.   if (gotten < numpbytes) then
  678.     begin
  679.     while (gotten < numpbytes) do
  680.       begin              (* slurp  up  excess *)
  681.       b := Dgrabbyte;
  682.       gotten := gotten + 1;
  683.       end;
  684.     end;  (* if *)
  685.   end; (* mainhandlespecials *)
  686.   
  687.   
  688.   (* ==================================================
  689.   
  690.   The routines below assume coordinates are already in
  691.     4th Quadrant DVI-space
  692.   
  693.   =====================================================*)
  694.   
  695.   
  696.   
  697.   {-----------------------------------------------------}
  698.   (* returns 0 if dy.dx not in font
  699.       1 if ok
  700.       2 if ok and caller should use two of the "code"s
  701.      coding scheme requires  0<= [dx, dy] <= 16
  702.      AND that max(dx, abs(dy)) is in [0,1,2,4,8,16]
  703.   *)
  704. function outvector (dx, dy : integer; var code : integer) : integer;
  705.   label 99;
  706.   var c : integer;
  707.       result : integer;
  708.   begin
  709.     if (dx < 0) then
  710.       begin
  711.       outvector := 0;
  712.       goto 99;
  713.       end;
  714.       
  715.     result := 0; (* init for potential failure *)
  716.     code := (-1);
  717.     if (dy < 0) then
  718.       begin
  719.       c := 160 + dy + dx - 9*max (dx, -dy);
  720.       end
  721.     else
  722.       begin
  723.       c := 160 + dy - dx - 7*max (dx, dy);
  724.       end;
  725.   
  726.     (* here translate to OUR coding scheme 
  727.      and return the correct number
  728.        this is needed because "c" thinks the char range
  729.        is 0 to 160, while we have only 128 chars *)
  730.   
  731.      if (c = 0) then       (* special cases *)
  732.        begin
  733.        code := 63; 
  734.        result := 2;
  735.        end
  736.      else if (c = 64) then
  737.        begin
  738.        code := 95;
  739.        result := 2;
  740.        end
  741.      else
  742.        begin       (* regular ones *)
  743.        result := 1;  (* just one char is fine *)
  744.        if (c in [1..63]) then
  745.      code := c - 1
  746.        else if (c in [80..112]) then
  747.      code := c - 17
  748.        else if (c in [120..136]) then
  749.      code := c - 24
  750.        else if (c in [140..148]) then
  751.      code := c - 27
  752.        else if (c in [150..154]) then
  753.      code := c - 28
  754.        else if (c = 160) then
  755.      code := 127; (* c - 33 *)
  756.        end;
  757.   99:
  758.    outvector := result;
  759.   end;
  760.   
  761.   
  762.   
  763.   (* take care of a Manhattan (horizontal /vertical) line *)
  764.   {----------------------------------------------------------} 
  765. procedure hvline (lx, by, rx, ty, fontindex : integer);
  766.   var t, rth, x, y, width, height : integer;
  767.   begin
  768.   rth := VFontTable[fontindex]^.PenSize; (* thickness of vector in sp *)
  769.   if (lx = rx) then
  770.     begin              (* Vertical line *)
  771.     if (ty > by) then       
  772.       begin
  773.       t := by; by := ty; ty := t;  (* swap *)
  774.       end;
  775.     x := round (lx - (rth / 2.0));
  776.     y := by;
  777.     width := rth;
  778.     height := by - ty;
  779.     end
  780.   else
  781.     begin              (* Horizontal line *)
  782.     if (ty < by) then
  783.       begin
  784.       t := by; by := ty; ty := t;  (* swap *)
  785.       end;
  786.     if (lx > rx) then
  787.       begin
  788.       t := lx; lx := rx; rx := t; (* swap *)
  789.       end;
  790.     x := lx;
  791.   
  792.     y := (by + (rth div 2)); (* + rth for {h,v}-space *)
  793.     width := rx - lx;
  794.     height := rth;
  795.     end;
  796.   
  797.   isetpos (x, y);
  798.   cmd1byte (PUTRULE);
  799.   cmd4byte (height);
  800.   cmd4byte (width);
  801.   
  802.   (* output two dots on ends of the rules
  803.    at    lx, by  and rx, ty  *)
  804.   (* the font has already been set before these calls *)
  805.   Tyldot (lx, by);
  806.   Tyldot (rx, ty);
  807.   isetpos (rx, ty);
  808.   end;
  809.   
  810.   
  811.   {------------------------------------------------------------}
  812. procedure diagonal (xl, yb, xr, yt : ScaledPts; fontindex: integer);
  813.   var t, curx, cury, dx, dy, code : integer;
  814.       slope : real;
  815.       mxveclen : ScaledPts;
  816.       sptovecs : real;
  817.       rho : ScaledPts;
  818.   
  819.       {......................................}
  820.       (* compute maximum length vector character that we  can use *)
  821.   
  822.       procedure  getincr (var outdx, outdy : integer);
  823.       label 99;
  824.        var radius, x, y : integer;
  825.        sign : integer;
  826.        q : real;
  827.   
  828.        begin  (* getincr *)
  829.        radius := mxveclen;   (* radius of semi-square *)
  830.        (* make sure the pt is outside of the semi-square,
  831.       scaling down radius if necessary *)
  832.        while ( ((xr - curx) < radius) and
  833.           (abs (yt - cury) < radius)) do
  834.      begin
  835.      radius := radius div 2;
  836.      end;
  837.        if (slope < 0.0) then  (* <0 since in 4th quad by now*)
  838.      sign := -1
  839.        else
  840.      sign := +1;
  841.        if (xr = curx) then
  842.      begin
  843.      outdx := 0;
  844.      outdy := sign * radius;
  845.      goto 99;
  846.      end;
  847.        if (yt = cury) then
  848.      begin
  849.      outdx := abs (radius);
  850.      outdy := 0;
  851.      goto 99;
  852.      end;
  853.   
  854.        (* compute the intersection with the semi-square,
  855.       choose whichever slope is best *)
  856.        if (abs (slope) < 1.0) then
  857.      begin              (* mostly horizontal *)
  858.      outdx := abs (radius);
  859.      y := yb + round ((curx + abs(radius) - xl) * slope); 
  860.      outdy := y - cury;
  861.      end
  862.        else
  863.      begin              (* mostly vertical *)
  864.      x := xl + round ((cury + (sign * radius) - yb) / slope); 
  865.      outdx := x - curx;
  866.      outdy := sign * radius;
  867.      end;
  868.   
  869.        if (abs (outdy) > abs (yt - cury)) then
  870.      begin         (* truncate *)
  871.      outdy := yt - cury;
  872.      end;
  873.        if (outdx > (xr - curx)) then
  874.      begin         (* truncate *)
  875.      outdx := xr - curx;
  876.      end;
  877.        if (outdx < 0) then
  878.      begin
  879.      outdx := 0;
  880.      end;
  881.   
  882.        (* method to find the exact intersection of the line segment
  883.     with the semi-circle, used
  884.     to determine the x and y values::
  885.     we do this by using the arctangent of the slope as
  886.     the angle 'a' from the x-axis. Then use the relation
  887.      y = r cos a, and x = r sin a
  888.     we can be smart about all this trig stuff by using
  889.     the relation :
  890.         sin (arctan a) = 1/sqrt(1 + a^2)
  891.         cos (arctan a) = a/sqrt(1 + a^2)
  892.     Thus:
  893.     q := (1.0 / sqrt (slope * slope + 1.0));
  894.     outdx := round (q * radius);
  895.     outdy := round (q * radius * slope);
  896.   
  897.     Unfortunately, we cannot access the Vector Font
  898.     coding scheme because the outdx, outdy 's produced
  899.     here do no conform to the condition
  900.         max (dx, abs(dy)) in [0,1,2,4,8,16]
  901.     when converted to vector-font sizes with 
  902.     sptovecs (see  the 'diagonal' proc.).
  903.     *)
  904.   
  905.   99:
  906.        end; (* getincr *)
  907.     {.......................................}
  908.   
  909.   begin (* DIAGONAL *)
  910.   if (xr <> xl) then
  911.     slope := (yt - yb) / (xr - xl)
  912.   else
  913.     slope := BIGREAL; (* some illegal value *)
  914.   
  915.   if (xl > xr) then
  916.     begin
  917.     t := xl; xl := xr; xr := t;
  918.     t := yb; yb := yt; yt := t;
  919.     end; (* swap *)
  920.     
  921.   curx := xl;
  922.   cury := yb;
  923.   mxveclen :=  (VFontTable[fontindex]^.MaxVectLen); 
  924.   rho := mxveclen div 16;  (* minimum radius of vector fonts *)
  925.   if (rho = 0) then
  926.     begin
  927.     complain (ERRREALBAD);
  928.     writeln(logfile,'Diagonal: Min radius of vector font is zero. setting to 1');
  929.     rho := 1;
  930.     end;
  931.   
  932.   if ((abs(xl - xr) <= rho) and
  933.       (abs(yb - yt) <= rho)) then
  934.     begin    (* pretty much a null line *)
  935.       Tyldot (xl, yb);
  936.     end
  937.   else
  938.     begin
  939.     sptovecs := 1.0 / rho; (* conversion for scaled pts to vectorfont units *)
  940.   
  941.     code := -1; (* initialize to a bogus number *)
  942.   
  943.     (* this conditional really has to have "or"
  944.         instead of "and", because of lines that are
  945.         *nearly*  horizontal or vertical
  946.     *)
  947.     while (((xr - curx) >= rho) or (abs(yt - cury) >= rho)) do  
  948.       begin
  949.   (* Get the approximate incremental amount. We use this dy/dx
  950.     pair in order to index into our vector font coding scheme *)
  951.   
  952.       getincr (dx, dy);
  953.   
  954.   (* Get the vector character code corresponding to this 
  955.     approximate incremental amount *)
  956.       t := outvector (round (dx * sptovecs), 
  957.               round (dy * sptovecs), 
  958.               code);
  959.   (* Now that we have the character code, go find out its actual
  960.     physical dimensions for the real dy/dx amounts *)
  961.       if (dy > 0) then
  962.      dy := VFontTable[fontindex]^.FontInfo[code].Cdp
  963.       else
  964.      dy := -(VFontTable[fontindex]^.FontInfo[code].Cht);
  965.   
  966.       dx := VFontTable[fontindex]^.FontInfo[code].Cwd;
  967.     
  968.       case (t) of
  969.        0: begin
  970.         complain (ERRREALBAD);
  971.         writeln (logfile,'Error in Diagonal:: bad dydx');
  972.       end;
  973.       
  974.        1: begin
  975.         isetpos (curx, cury);
  976.         iputchar (code);
  977.       end;
  978.           
  979.        2: begin
  980.         isetpos (curx, cury);
  981.         iputchar (code);
  982.         isetpos (curx + (dx div 2),  cury + (dy div 2));
  983.         iputchar (code);
  984.       end;
  985.       end; (* case *)
  986.   
  987.       curx := curx + dx;
  988.       cury := cury + dy;
  989.       end; (* while *)
  990.   
  991.     if ((code >= 0) and
  992.      (((xr - curx) >= rho) and (abs(yt - cury) >= rho))) then
  993.       begin
  994.       iputchar (code);
  995.       end;
  996.     end;   (* not null line *)
  997.   end;
  998.  
  999.  
  1000. {-------------------------------------------------------}
  1001.